CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/swagg_m.zip/MISC.SWG/0103_DBase III Routines.pas

Pascal/Delphi Source File | 1994-08-24 | 37KB | 1,410 lines

{---------------------------------------------------------}
{  Unit    : Dbase III Access Routines                    }
{  Auteur  : Ir. G.W. van der Vegt                        }
{            Hondsbroek 57                                }
{            6121 XB Born                                 }
{---------------------------------------------------------}
{  Datum .tijd  Revisie                                   }
{  910701.2130  Creatie.                                  }
{  910702.1000  Minor Errors Corrected                    }
{               Replace, Append & Pack Added              }
{  910706.2400  dbrec on the Heap (recsize max 64kB-16)   }
{               Uppercase Conversion in Bd3_fileno        }
{               Optional Halt on (fatal) Errors           }
{  910710.1500  Memo Field Support                        }
{  910715.2330  Field2num bug fixed (leading sp. removed) }
{  910960.1130  Fieldno Out of range detection            }
{  920116.1000  Two minor bugs fixed                      }
{  920124.2200  Header updated when file is closed,       }
{               Db3_Seekbof & Db3_Seekeof added           }
{               Db3_Findfirst & Db3_Findnext implemented  }
{               for wildcard search of records            }
{               Db3_soudex & Db3_field2soundex for Soundex}
{               code (sound alike) operations             }
{               Db3_firstsoudex & Db3_nextsoundex for     }
{               soundex search on a field                 }
{  920127.1300  Dbase Slack Filespace Detection &         }
{               Correction                                }
{  920129.2115  Trailing spaces remover in Db3_field2str  }
{               Seek after truncate in Db3_open           }
{  920130.2145  Slack filespace bug removed               }
{               Db3_sort implemented (based on shakersort)}
{               Bug in Db3_date2field removed             }
{  920716.2130  Empty file pack fixed in Db3_pack         }
{  920928.2200  Obscure bug in Db3_fieldname. Fieldnames  }
{               seem to be are ASCIZ in stead of fixed    }
{               length strings.                           }
{  930927.2000  Freemem bug in db3_findnext corrected.    }
{---------------------------------------------------------}
{  To Do        Full Documentation                        }
{               Write Memo Support                        }
{               Extend Db3_pack with MemoFile Packing     }
{               Sort *.DBF in place                       }
{               Insert record in *.DBF file               }
{               Date format not always yy-mm-dd           }
{---------------------------------------------------------}

UNIT Db3_01;

INTERFACE

USES
  DOS;

{---------------------------------------------------------}
{----Error Handling : Returns First Error Which Occured   }
{---------------------------------------------------------}

VAR
  db3_ernr     : INTEGER;                    {----DB3 Module Error Code}
  db3_fatal    : BOOLEAN;                    {----IF True
                                                    THEN Halt(db3_ernr)
                                                  on an error}

  db3_memotext : TEXT;                       {----Memo File}

{---------------------------------------------------------}

FUNCTION  Db3_ermsg(nr : INTEGER) : STRING;

{---------------------------------------------------------}
{----Initialize/Exit : Must both be Called for every file }
{---------------------------------------------------------}

PROCEDURE Db3_open(fn : STRING);             {----Opens fn.DBF file &
                                                  Inits Internals}
PROCEDURE Db3_close;                         {----Closes fn.DBF file}

{---------------------------------------------------------}
{----Header Function : Get .DBF header info               }
{---------------------------------------------------------}

FUNCTION  Db3_memo : BOOLEAN;

FUNCTION  Db3_update : STRING;

FUNCTION  Db3_norecs : LONGINT;

FUNCTION  Db3_nofields : INTEGER;

FUNCTION  Db3_reclen : INTEGER;

{---------------------------------------------------------}
{----File I/O : Dbase III Alike (pos etc. in records)     }
{---------------------------------------------------------}

PROCEDURE Db3_seek(pos : LONGINT);

FUNCTION  Db3_filesize : LONGINT;

FUNCTION  Db3_filepos : LONGINT;

PROCEDURE Db3_readnext;

PROCEDURE Db3_read(pos : LONGINT);

PROCEDURE Db3_seekeof;

PROCEDURE Db3_seekbof;

FUNCTION  Db3_eof : BOOLEAN;

FUNCTION  Db3_bof : BOOLEAN;

PROCEDURE Db3_replace(no : LONGINT);         {----First Read record &
                                                  Fill all fields}
PROCEDURE Db3_append;                        {----First Fill all Fields}

PROCEDURE Db3_delete(no : LONGINT);

PROCEDURE Db3_undelete(no : LONGINT);

PROCEDURE Db3_pack;                          {----Packs File IN-PLACE}

PROCEDURE Db3_blankrec;

{---------------------------------------------------------}
{----Field Operations : no is .DBF field number           }
{---------------------------------------------------------}

FUNCTION  Db3_fieldname(no : INTEGER) : STRING;

FUNCTION  Db3_fieldlen(no : INTEGER) : INTEGER;

FUNCTION  Db3_fielddec(no : INTEGER) : INTEGER;

FUNCTION  Db3_fieldno(name : STRING) : INTEGER; {----Searches Fieldnumber for
                                                     Uppercase fieldname}
FUNCTION  Db3_fieldtype(no : INTEGER) : CHAR;

FUNCTION  Db3_deleted : BOOLEAN;

{---------------------------------------------------------}
{----Field Conversions : date format 'dd-mm-19yy'         }
{---------------------------------------------------------}

FUNCTION  Db3_field2str(no :INTEGER) : STRING;

FUNCTION  Db3_field2char(no :INTEGER) : CHAR;

FUNCTION  Db3_field2logic(no : INTEGER) : BOOLEAN;

FUNCTION  Db3_field2num(no : INTEGER) : REAL;

FUNCTION  Db3_field2date(no :INTEGER) : STRING;

PROCEDURE Db3_field2memo(no : INTEGER);

FUNCTION  Db3_field2soundex(no : INTEGER) : STRING;

PROCEDURE Db3_str2field(no :INTEGER;s : STRING);

PROCEDURE Db3_char2field(no :INTEGER;s : CHAR);

PROCEDURE Db3_logic2field(no : INTEGER;l : BOOLEAN);

PROCEDURE Db3_num2field(no : INTEGER;n : REAL);

PROCEDURE Db3_date2field(no :INTEGER;d : STRING);

{---------------------------------------------------------}
{----Database Search, spaces are used as wildcards.       }
{    Db3_blankrec can be used for creating a wildcard     }
{    record. Then if Findfirst is true the use Findnext   }
{    until Findnext becomes false. After each succesfull  }
{    call the internal readbuffer will contain the        }
{    matching record. Use casesense=true for a case       }
{    sensitive search.                                    }
{---------------------------------------------------------}

FUNCTION Db3_findfirst(cs : BOOLEAN) : BOOLEAN;

FUNCTION Db3_findnext(cs : BOOLEAN) : BOOLEAN;

{---------------------------------------------------------}
{----Soundex Code Function (sound alike)                  }
{---------------------------------------------------------}

FUNCTION  Db3_soundex(name : STRING) : STRING;

FUNCTION  Db3_firstsoundex(no : INTEGER; s : STRING) : BOOLEAN;

FUNCTION  Db3_nextsoundex(no : INTEGER; s : STRING) : BOOLEAN;

{---------------------------------------------------------}
{----Shaker Sort Almost Sorted *.DBF Files                }
{---------------------------------------------------------}

PROCEDURE Db3_sort(no : INTEGER);

IMPLEMENTATION

{---------------------------------------------------------}
{----Error Handling                                       }
{---------------------------------------------------------}

PROCEDURE Seternr(e : INTEGER);

BEGIN
  IF (db3_ernr=0) THEN db3_ernr:=e;
  IF db3_fatal
    THEN
      BEGIN
        Writeln;
        Writeln('Db3_01 [Error : ',db3_ernr:0,' = '+Db3_ermsg(db3_ernr)+']');
        Writeln;
        IF (db3_ernr<>1) THEN Db3_close;
        Halt(e);
      END;
END; {of Seternr}

{---------------------------------------------------------}

FUNCTION  Db3_ermsg(nr : INTEGER) : STRING;

BEGIN
  CASE nr OF
    0 : Db3_ermsg:='No Error';
    1 : Db3_ermsg:='Error Opening File';
    2 : Db3_ermsg:='Seek Past EOF';
    3 : Db3_ermsg:='Seek Before BOF';
    4 : Db3_ermsg:='Read Past EOF';
    5 : Db3_ermsg:='Invalid Numeric Field';
    6 : Db3_ermsg:='Field Name NOT Found';
    7 : Db3_ermsg:='Invalid Header';
    8 : Db3_ermsg:='Incorrect Filesize';
    9 : Db3_ermsg:='Records to Large';
   10 : Db3_ermsg:='To many Fields';
   11 : Db3_ermsg:='Invalid Date Format';
   12 : Db3_ermsg:='Cannot Format Real';
   13 : Db3_ermsg:='Record was already deleted';
   14 : Db3_ermsg:='Record was not deleted';
   15 : Db3_ermsg:='NOT a Dbase III File';
   16 : Db3_ermsg:='Field Number NOT Found';
   17 : Db3_ermsg:='No Memofields in this file';
   18 : Db3_ermsg:='All matching records already found';
   19 : Db3_ermsg:='No *.DBF file open';
   20 : Db3_ermsg:='*.DBF already file open';
   99 : Db3_ermsg:='NOT Yet Implemented';
  ELSE Db3_ermsg:='Unkown Error';
  END;

  db3_ernr:=0;
END; {of Db3_ermsg}

{---------------------------------------------------------}
{----Types/Vars & Constants                               }
{---------------------------------------------------------}

TYPE
  dbheader = RECORD
               dbvers : BYTE;
               dbupdy,
               dbupdm,
               dbupdd : BYTE;
               dbnorec: LONGINT;
               dbheadl,
               dbrecl : INTEGER;
               dbres  : ARRAY[1..20] OF BYTE;
             END;

  dbfield  = RECORD                          {----Definition of Field Header}
               dbname : ARRAY[1..11] OF CHAR;
               dbtype : CHAR;
               dbadr  : LONGINT;
               dblen,
               dbdec  : BYTE;
               dbres  : ARRAY[1..14] OF CHAR;
             END;

  fptr     = RECORD                          {----Definition of Readbuf Index}
               fppos   : WORD;
               fplen   : BYTE;
             END;

CONST
  maxfield =    60;                          {----Max number of Fields}
  maxsize  = 65000;                          {----Maximum Record Size}

TYPE
  rectyp   = ARRAY[0..maxsize] OF CHAR;      {----Record Readbuffer Type}

VAR
  f        : file;                           {----.DBF File}

  header   : dbheader;                       {----Space for Header}
  nofields : INTEGER;                        {----Number of Fields}

  fields   : ARRAY[1..maxfield] OF dbfield;  {----Field Definitions}
  fieldptr : ARRAY[1..maxfield] OF fptr;     {----Index into Readbuffer}
  recstart : LONGINT;                        {----Start of Record Area}

  dbrec    : ^rectyp;                        {----Record Buffer}
  reclen   : WORD;                           {----Record Length}

  memo     : FILE;                           {----Memo File}
  memopos  : LONGINT;                        {----Location of Memo Record}
  memobuf  : ARRAY[1..512] OF CHAR;          {----Memo Text File buffer}

  dbsearch : ^rectyp;                        {----Search Record Buffer}

{---------------------------------------------------------}
{----Initialize                                           }
{---------------------------------------------------------}

PROCEDURE Db3_open(fn : STRING);

VAR
  i   : INTEGER;
  j   : WORD;
  ch  : CHAR;

BEGIN
  IF (dbrec<>NIL)
    THEN Seternr(20)
    ELSE
      BEGIN
        Assign(f,fn+'.DBF');
        {$I-} Reset(f,1); {$I+}
        IF (Ioresult<>0)
          THEN Seternr(1)
          ELSE
            BEGIN
            {----Dump Header}
              Blockread(f,header,32);

              Getmem(dbrec,header.dbrecl+1);

            {---Scan for Fieldnames & Recordlength}
              reclen  :=1;
              nofields:=0;
              Blockread(f,ch,1);
              WHILE (nofields<maxfield) AND (ch<>#13) DO
                BEGIN
                  Inc(nofields);
                  WITH fields[nofields] DO
                    BEGIN
                      dbname[1]:=ch;
                      Blockread(f,dbname[2],Sizeof(dbfield)-1);
                      Inc(reclen,dblen);
                      Blockread(f,ch,1);
                    END;
                END;

              IF (ch<>#13) THEN Seternr(10);

            {----Zapped file contains only a EOF}
              recstart:=Filepos(f);

            {----Set fieldptr}
              j:=1;
              FOR i:=1 TO nofields DO
                WITH fieldptr[i],fields[i] DO
                  BEGIN
                    fplen:=dblen;
                    fppos:=j;
                    Inc(j,dblen);
                  END;

            {----Header Integrity Checks}
              IF NOT(header.dbvers IN [$03,$83]) THEN Seternr(15);

              IF ((header.dbheadl DIV 32)-1<>nofields) OR
                  (header.dbrecl<>reclen)
                THEN Seternr(7);

            {----File Size Check}
              IF (header.dbnorec*reclen<>(Filesize(f)-recstart-1))
                THEN
                  BEGIN
                  {----Truncate DBASE Slack Filespace}
                  { Writeln('Truncating'); }
                    Db3_Seek(header.dbnorec+1);
                    {$I-} Seek(f,Filepos(f)+1); {$I+}
                    IF (IOresult=0)
                      THEN Truncate(f)
                      ELSE Seternr(8);
                  END;

              IF (reclen>Sizeof(rectyp)) THEN Seternr(9);

              IF Db3_memo
                THEN
                  BEGIN
                    Assign(memo,fn+'.DBT');
                    {$I-} Reset(memo,1); {$I+}
                    IF (IOresult<>0) THEN Seternr(17);
                  END;

              IF (db3_ernr<>0) THEN Freemem(dbrec,header.dbrecl+1);
            END;

        IF (db3_ernr<>0)
          THEN dbrec:=NIL
          ELSE Db3_Seekbof

      END;
END; {of Db3_open}

{---------------------------------------------------------}

PROCEDURE Db3_close;

VAR
  y,m,d,dow : WORD;

BEGIN
  IF (dbrec<>NIL)
    THEN
      BEGIN
      {----Update *.DBF File Header}
        Getdate(y,m,d,dow);
        WITH header DO
          BEGIN
            dbupdy :=y MOD 100;
            dbupdm :=m;
            dbupdd :=d;
            dbnorec:=Db3_filesize;
          END;
        Reset(f,1);
        Blockwrite(f,header,32);
        Close(f);

      {----Cleanup Memory}
        Freemem(dbrec,header.dbrecl+1);
        IF dbsearch<>NIL THEN Freemem(dbsearch,header.dbrecl+1);

        dbrec    :=NIL;
        dbsearch :=NIL;
      END
    ELSE Seternr(19);
END; {of DB3_close}

{---------------------------------------------------------}
{----Header Operations                                    }
{---------------------------------------------------------}

FUNCTION  Db3_memo : BOOLEAN;

BEGIN
  Db3_memo:=header.dbvers=$83;
END; {of Db3_memo}

{---------------------------------------------------------}

FUNCTION  Db3_update : STRING;

VAR
  s : STRING;

BEGIN
  s:='dd-mm-19yy';
  s[ 1]:=Chr(Ord('0')+header.dbupdd DIV 10);
  s[ 2]:=Chr(Ord('0')+header.dbupdd MOD 10);
  s[ 4]:=Chr(Ord('0')+header.dbupdm DIV 10);
  s[ 5]:=Chr(Ord('0')+header.dbupdm MOD 10);
  s[ 9]:=Chr(Ord('0')+header.dbupdy DIV 10);
  s[10]:=Chr(Ord('0')+header.dbupdy MOD 10);

  Db3_update:=s;
END; {of Db3_update}

{---------------------------------------------------------}

FUNCTION  Db3_norecs : LONGINT;

BEGIN
  Db3_norecs:=header.dbnorec;
END; {of Db3_norecs}

{---------------------------------------------------------}

FUNCTION  Db3_nofields : INTEGER;

BEGIN
  Db3_nofields:=nofields;
END; {of Db3_nofields}

{---------------------------------------------------------}

FUNCTION  Db3_reclen : INTEGER;

BEGIN
  Db3_reclen:=reclen;
END; {of Db3_reclen}

{---------------------------------------------------------}
{----File I/O                                             }
{---------------------------------------------------------}

PROCEDURE Db3_seek(pos : LONGINT);

BEGIN
  {$I-} Seek(f,recstart+(pos-1)*reclen); {$I+}
  IF (Ioresult<>0) OR (pos<1) OR (pos>Db3_filesize+1)
    THEN
      BEGIN
        IF (pos>0)
          THEN Seternr(2)
          ELSE Seternr(3);
      END;
END; {of Db3_seek}

{---------------------------------------------------------}

FUNCTION  Db3_filesize : LONGINT;

BEGIN
  Db3_filesize:=(Filesize(f)-recstart) DIV reclen;
END; {of Db3_filesize}

{---------------------------------------------------------}

FUNCTION  Db3_filepos : LONGINT;

BEGIN
  Db3_filepos:=((Filepos(f)-recstart) DIV reclen)+1;
END; {of Db3_filepos}

{---------------------------------------------------------}

PROCEDURE Db3_readnext;

BEGIN
  IF EOF(f) OR Db3_Eof
    THEN Seternr(4)
    ELSE Blockread(f,dbrec^,reclen);
END; {of Db3_readnext}

{---------------------------------------------------------}

PROCEDURE Db3_read(pos : LONGINT);

BEGIN
  Db3_seek(pos);
  Db3_readnext;
END; {of Db3_read}

{---------------------------------------------------------}

PROCEDURE Db3_seekeof;

BEGIN
  Db3_Seek(Db3_filesize+1);
END; {of Db3_seekeof}

{---------------------------------------------------------}

PROCEDURE Db3_seekbof;

BEGIN
  Seek(f,recstart);
END; {of Db3_seekeof}

{---------------------------------------------------------}

FUNCTION  Db3_eof : BOOLEAN;

BEGIN
  Db3_eof:=(Filepos(f)>=Filesize(f)-1);
END; {of Db3_eof}

{---------------------------------------------------------}

FUNCTION  Db3_bof : BOOLEAN;

BEGIN
  Db3_bof:=Filepos(f)=recstart;
END; {of Db3_bof}

{---------------------------------------------------------}

PROCEDURE Db3_replace(no : LONGINT);

BEGIN
  Db3_seek(no);
  IF (db3_ernr=0) THEN Blockwrite(f,dbrec^[0],reclen)
END; {of Db3_append}

{---------------------------------------------------------}

PROCEDURE Db3_append;

VAR
  ch : CHAR;

BEGIN
  Db3_seek(Db3_filesize+1);
  Blockwrite(f,dbrec^[0],reclen);
  ch:=^Z;
  Blockwrite(f,ch,1);
  Db3_seek(Db3_filesize+1);
END; {of Db3_append}

{---------------------------------------------------------}

PROCEDURE Db3_delete(no : LONGINT);

BEGIN
  Db3_read(no);
  IF dbrec^[0]='*'
    THEN Seternr(13)
    ELSE dbrec^[0]:='*';
  Db3_replace(no)
END; {of Db3_delete}

{---------------------------------------------------------}

PROCEDURE Db3_undelete(no : LONGINT);

BEGIN
  Db3_read(no);
  IF dbrec^[0]=' '
    THEN Seternr(14)
    ELSE dbrec^[0]:=' ';
  Db3_replace(no)
END; {of Db3_undelete}

{---------------------------------------------------------}

PROCEDURE Db3_pack;

VAR
  i,j : LONGINT;
  ch  : CHAR;

BEGIN
  j:=0;
  FOR i:=1 TO Db3_filesize DO
    BEGIN
      Db3_read(i);
      IF NOT(Db3_deleted)
        THEN
          BEGIN
            Inc(j);
            Db3_replace(j)
          END
    END;

{----New EOF Marker}
  IF (j=0)
    THEN db3_SeekBof
    ELSE Db3_read(j);
  ch:=^Z;
  Blockwrite(f,ch,1);
  Truncate(f);

  Db3_seek(1);
END; {of Db3_pack}

{---------------------------------------------------------}

PROCEDURE Db3_blankrec;

VAR
  i : INTEGER;

BEGIN
  FOR i:=0 TO reclen-1 DO dbrec^[i]:=#32;
END; {of Db3_blankrec}

{---------------------------------------------------------}
{----Field Operations                                     }
{---------------------------------------------------------}

FUNCTION  Db3_fieldname(no : INTEGER) : STRING;

VAR
  s : STRING;
  i : WORD;

BEGIN
  s:='';
  i:=1;
  IF no IN [1..nofields]
    THEN
      BEGIN
        WITH fields[no] DO
          WHILE (i<=Sizeof(dbname)) AND (dbname[i]<>#0) DO
            BEGIN
              s:=s+dbname[i];
              Inc(i);
            END;
      END
    ELSE Seternr(16);
  Db3_fieldname:=s;
END; {of Db3_fieldname}

{---------------------------------------------------------}

FUNCTION  Db3_fieldlen(no : INTEGER) : INTEGER;

BEGIN
  Db3_fieldlen:=0;
  IF no IN [1..nofields]
    THEN Db3_fieldlen:=fields[no].dblen
    ELSE Seternr(16);
END; {of Db3_fieldlen}

{---------------------------------------------------------}

FUNCTION  Db3_fielddec(no : INTEGER) : INTEGER;

BEGIN
  Db3_fielddec:=0;
  IF no IN [1..nofields]
    THEN Db3_fielddec:=fields[no].dbdec
    ELSE Seternr(16)
END; {of Db3_fielddec}

{---------------------------------------------------------}

FUNCTION  Db3_fieldno(name : STRING) : INTEGER;

VAR
  i,j : INTEGER;
  s   : STRING;

BEGIN
  Db3_fieldno:=0;

  s:=name;
  FOR i:=1 TO Length(s) DO s[i]:=Upcase(s[i]);

  i:=1;
  WHILE (i<=nofields) AND (s<>Db3_fieldname(i)) DO
    Inc(i);

  IF (i>nofields)
    THEN Seternr(6)
    ELSE Db3_fieldno:=i;
END; {of Db3_fieldno}

{---------------------------------------------------------}

FUNCTION  Db3_fieldtype(no : INTEGER) : CHAR;

BEGIN
  Db3_fieldtype:=#00;
  IF no IN [1..nofields]
    THEN Db3_fieldtype:=fields[no].dbtype
    ELSE Seternr(16);
END; {of Db3_fieldtype}

{---------------------------------------------------------}

FUNCTION  Db3_deleted : BOOLEAN;

BEGIN
  Db3_deleted:=dbrec^[0]<>#32;
END; {of Db3_deleted}

{---------------------------------------------------------}
{----Field Conversions                                    }
{---------------------------------------------------------}

FUNCTION  Db3_field2str(no :INTEGER) : STRING;

VAR
  s : STRING;
  i : WORD;

BEGIN
  s:='';
  IF (no IN [1..nofields])
    THEN
      BEGIN
        s[0]:=Chr(fieldptr[no].fplen);
        Move(dbrec^[fieldptr[no].fppos],s[1],fieldptr[no].fplen);
      END
    ELSE Seternr(16);
{----Strip Trailing Spaces}
  WHILE (Length(s)>0) AND (s[Length(s)]=#32) DO Dec(s[0]);
  Db3_field2str:=s;
END; {of Db3_field2str}

{---------------------------------------------------------}

FUNCTION Db3_field2char(no :INTEGER) : CHAR;

VAR
  s : STRING;

BEGIN
  IF (Db3_fieldlen(no)=1)
    THEN s:=Db3_field2str(no)
    ELSE s:=#00;

  IF (Length(s)=0)
    THEN Db3_field2char:=#32
    ELSE Db3_field2char:=s[1];
END; {of Db3_field2char}

{---------------------------------------------------------}

FUNCTION Db3_field2logic(no : INTEGER) : BOOLEAN;

BEGIN
  Db3_field2logic:=(Db3_field2char(no)='T');
END; {of Db3_field2logic}

{---------------------------------------------------------}

FUNCTION  Db3_field2num(no : INTEGER) : REAL;

VAR
  r : REAL;
  s : STRING;
  e : INTEGER;

BEGIN
  s:=Db3_field2str(no);
  WHILE (Length(s)>0) AND (s[1]=#32) DO Delete(s,1,1);
  Val(s,r,e);
  IF (e<>0)
    THEN Seternr(5);
  Db3_field2num:=r;
END; {of Db3_field2num}

{---------------------------------------------------------}

FUNCTION  Db3_field2date(no :INTEGER) : STRING;

VAR
  s : STRING;

BEGIN
  s:='dd-mm-yyyy';
  IF (no IN [1..nofields])
    THEN
      BEGIN
        Move(dbrec^[fieldptr[no].fppos+6],s[1],2);
        Move(dbrec^[fieldptr[no].fppos+4],s[4],2);
        Move(dbrec^[fieldptr[no].fppos+0],s[7],4);
      END
    ELSE Seternr(16);

  Db3_field2date:=s;
END; {of Db3_field2date}

{---------------------------------------------------------}

FUNCTION Db3_field2soundex(no : INTEGER) : STRING;

BEGIN
  Db3_field2soundex:=Db3_soundex(Db3_field2str(no));
END; {of Db3_field2soundex}

{---------------------------------------------------------}

PROCEDURE Db3_str2field(no :INTEGER;s : STRING);

BEGIN
  IF (no IN [1..nofields])
    THEN
      BEGIN
        Fillchar(dbrec^[fieldptr[no].fppos],fieldptr[no].fplen,#32);
        WITH fields[no] DO
          IF (Length(s)>dblen)
            THEN Move(s[1],dbrec^[fieldptr[no].fppos],dblen)
            ELSE Move(s[1],dbrec^[fieldptr[no].fppos],Length(s));
      END
    ELSE Seternr(16)
END; {of Db3_str2field}

{---------------------------------------------------------}

PROCEDURE Db3_char2field(no :INTEGER;s : CHAR);

BEGIN
  Db3_str2field(no,s);
END; {of Db3_char2field}

{---------------------------------------------------------}

PROCEDURE Db3_logic2field(no : INTEGER;l : BOOLEAN);

BEGIN
  IF l
    THEN Db3_char2field(no,'T')
    ELSE Db3_char2field(no,'F')
END; {of Db3_logic2field}

{---------------------------------------------------------}

PROCEDURE Db3_num2field(no : INTEGER;n: REAL);

VAR
  s : STRING;

BEGIN
  IF (no IN [1..nofields])
    THEN
      BEGIN
        Str(n:fields[no].dblen:fields[no].dbdec,s);
        IF (Length(s)>fields[no].dblen)
          THEN Seternr(12)
          ELSE Db3_str2field(no,s);
      END
    ELSE Seternr(16)
END; {of Db3_num2field}

{---------------------------------------------------------}

PROCEDURE Db3_date2field(no :INTEGER;d : STRING);

VAR
  s : STRING;

BEGIN
  IF (Length(d)<>10) OR
     (d[3]<>'-') OR
     (d[6]<>'-')
    THEN Seternr(11)
    ELSE
      BEGIN
      {----dd-mm-yyyy}
        s[1]:=d[ 7];
        s[2]:=d[ 8];
        s[3]:=d[ 9];
        s[4]:=d[10];
        s[5]:=d[ 4];
        s[6]:=d[ 5];
        s[7]:=d[ 1];
        s[8]:=d[ 2];
        Db3_str2field(no,s);
      END;
END; {of Db3_date2field}

{---------------------------------------------------------}
{----Memo text field support                              }
{---------------------------------------------------------}

{$F+}

FUNCTION memoignore(VAR f : textrec) : INTEGER;

BEGIN
  memoignore:=0;
END; {of memoignore}

{---------------------------------------------------------}

FUNCTION memoinput(VAR f : textrec) : INTEGER;

VAR
  chread : WORD;

BEGIN
  WITH Textrec(f) DO
    BEGIN
      Blockread(memo,memobuf[1],Sizeof(memobuf),chread);
      bufpos   :=0;
      bufend   :=chread;
    END;
  memoinput:=0;
END; {of memoinput}

{$F-}

{---------------------------------------------------------}

PROCEDURE Assignmemo(VAR f : TEXT);

VAR
  chread : WORD;

CONST
  fminput =$D7B1;

BEGIN
  WITH Textrec(f) DO
    BEGIN
      handle   :=$ffff;
      mode     :=fminput;
      bufsize  :=SIZEOF(memobuf);
      bufpos   :=0;
      bufptr   :=@memobuf;

      Blockread(memo,memobuf[1],Sizeof(memobuf),chread);
      bufpos   :=0;
      bufend   :=chread;

      openfunc :=@memoignore;
      inoutfunc:=@memoinput;
      flushfunc:=@memoignore;
      closefunc:=@memoignore;
      name[0]  :=#00;
    END;
END; {of Assignmemo}

{---------------------------------------------------------}

PROCEDURE Db3_field2memo(no : INTEGER);

VAR
  e  : INTEGER;
  s  : STRING;

BEGIN
  IF Db3_memo
    THEN
      BEGIN
        s:=Db3_field2str(no);
        WHILE (Length(s)>0) AND (s[1]=#32) DO Delete(s,1,1);
        Val(s,memopos,e);
        IF (e<>0)
          THEN Seternr(5)
          ELSE
            BEGIN
              Seek(memo,memopos*Sizeof(memobuf));
              Assignmemo(db3_memotext);
            END;
      END
    ELSE Seternr(17);
END; {of Db3_field2memo}

{---------------------------------------------------------}

FUNCTION Db3_findfirst(cs : BOOLEAN) : BOOLEAN;

VAR
  match,
  found : BOOLEAN;
  i     : INTEGER;

BEGIN
  Getmem(dbsearch,Db3_reclen+1);
  Move(dbrec^,dbsearch^,Db3_reclen);

  Db3_Seekbof;

  found:=False;
  WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DO
    BEGIN
      Db3_readnext;

      i:=0;
      match:=true;
      WHILE (i<Db3_reclen) AND match DO
        BEGIN
          IF (dbsearch^[i]<>#32)
            THEN
              CASE cs OF
                TRUE  : match:=(       dbsearch^[i] =       dbrec^[i]);
                FALSE : match:=(Upcase(dbsearch^[i])=Upcase(dbrec^[i]));
              END;
          INC(i);
        END;
      found:=match;
    END;

  Db3_findfirst:=found;

  IF (found=False)
    THEN
      BEGIN
        Freemem(dbsearch,Db3_reclen+1);
        dbsearch:=NIL;
      END;
END; {of Db3_findfirst}

{---------------------------------------------------------}

FUNCTION Db3_findnext(cs : BOOLEAN) : BOOLEAN;

VAR
  match,
  found : BOOLEAN;
  i     : INTEGER;

BEGIN
  IF (dbsearch=NIL)
    THEN Seternr(18);

  found:=False;
  WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DO
    BEGIN
      Db3_readnext;

      i:=0;
      match:=true;
      WHILE (i<Db3_reclen) AND match DO
        BEGIN
          IF (dbsearch^[i]<>#32)
            THEN
              CASE cs OF
                TRUE  : match:=(       dbsearch^[i] =       dbrec^[i]);
                FALSE : match:=(Upcase(dbsearch^[i])=Upcase(dbrec^[i]));
              END;
          INC(i);
        END;
      found:=match;
    END;

  Db3_findnext:=found;

  If (found=False) AND (dbsearch<>NIL)
    Then
      BEGIN
        Freemem(dbsearch,Db3_reclen+1);
        dbsearch:=NIL;
      END;
END; {of Db3_findnext}

{---------------------------------------------------------}

FUNCTION  Db3_soundex(name : STRING) : STRING;

VAR
  work : STRING;
  code : CHAR;
  i,j  : INTEGER;

  {---------------------------------------------------------}

  FUNCTION Encode(VAR c: CHAR): CHAR;

  BEGIN
    CASE Upcase(c) OF
      'B','F','P','V':                 encode:='1';
      'C','G','J','K','Q','S','X','Z': encode:='2';
      'D','T':                         encode:='3';
      'L':                             encode:='4';
      'M','N':                         encode:='5';
      'R':                             encode:='6';
      'A','E','I','O','U','Y':         encode:='7';
      'H','W':                         encode:='8';
    ELSE                               encode:=' ';
    END;
  END; {of Encode}

  {---------------------------------------------------------}

BEGIN
{----If we can't calculate, this is the answer}
  work:='';

{----Skip all non alpha codes in front}
  i:=1;
  WHILE (i<=Length(name)) AND (Encode(name[i])=' ') DO Inc(i);

{----If any alpha characters left, start calculating the SOUNDEX code}
  IF (i<=Length(name))
    THEN
      BEGIN
      {----The first alpha letter of string is the first letter of the code}
        work:=Upcase(name[i]);
        Inc(i);

      {----Be sure while loop precondition is correct}
        j:=1;
        code:=#00;

      {----Calculate the numeric part of the code,    }
      {    with a maximum of 3 digits, stop if a non  }
      {    alpha character is encountered             }
        WHILE (i<=Length(name)) AND (j<=3) AND (code<>' ') DO
          BEGIN
            code:=Encode(name[i]);

          {----If new code group then add the goup number}
            IF (code IN ['1'..'6']) AND (work[j]<>code)
              THEN
                BEGIN
                  Inc(j);
                  work:=work+code;
                END;
            Inc(i);
          END;
      END;

{----Return the resulting SOUNDEX code}
  Db3_soundex:=work;

END; {of Db3_soundex}

{---------------------------------------------------------}

FUNCTION Db3_firstsoundex(no : INTEGER;s : STRING) : BOOLEAN;

VAR
  found : BOOLEAN;
  sdx   : STRING;

BEGIN
  Db3_Seekbof;

  sdx:=Db3_soundex(s);

  found:=False;
  WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DO
    BEGIN
      Db3_readnext;
      found:=(Pos(sdx,Db3_field2soundex(no))=1);
    END;

  Db3_firstsoundex:=found;
END; {of Db3_firstsoundex}

{---------------------------------------------------------}

FUNCTION Db3_nextsoundex(no : INTEGER; s : STRING) : BOOLEAN;

VAR
  found : BOOLEAN;
  sdx   : STRING;

BEGIN
  sdx:=Db3_soundex(s);

  found:=False;
  WHILE NOT(found OR Db3_eof OR (Db3_ernr<>0)) DO
    BEGIN
      Db3_readnext;
      found:=(Pos(sdx,Db3_field2soundex(no))=1);
    END;

  Db3_nextsoundex:=found;
END; {of Db3_nextsoundex}

{---------------------------------------------------------}

PROCEDURE Db3_sort(no : INTEGER);

VAR
  dbsort    : ^rectyp;
  swapped   : BOOLEAN;
  i,j,l,r   : LONGINT;
  s1,s2     : STRING;
  typ       : CHAR;

  {---------------------------------------------------------}

  PROCEDURE Swap(r1,r2 : LONGINT);

  BEGIN
  {----Side Effects}
    i:=j;
    swapped:=True;

  {----the Swapping itself}
    Db3_replace(r1);
    Move(dbsort^,dbrec^,Db3_reclen);
    Db3_replace(r2);
  END; {of Swapped}

  {---------------------------------------------------------}

  FUNCTION Compare(VAR c1,c2 : STRING) : BOOLEAN;

  VAR
    i : INTEGER;
    s : STRING;

  BEGIN
    CASE typ OF
      'M',
      'N'  : BEGIN
             {----Insert spaces for correct numeric compare}
               FOR i:=1 TO Db3_fieldlen(no)-Length(c1) DO Insert(#32,c1,i);
               FOR i:=1 TO Db3_fieldlen(no)-Length(c2) DO Insert(#32,c2,i);
             END;
      'L',
      'S',
      'C'  : BEGIN
             {----Convert to Uppercase for correct alpha compare}
               FOR i:=1 TO Length(c1) Do c1[i]:=Upcase(c1[i]);
               FOR i:=1 TO Length(c2) Do c2[i]:=Upcase(c2[i]);
             END;
      'D'  : ;
    END;

  {----Return TRUE if c2>c1}
    Compare:=(c2>c1);
  END; {of Compare}

  {---------------------------------------------------------}

BEGIN
{----Use ShakerSort on almost sorted *.DBF file}
  Getmem(dbsort,Db3_reclen+1);
  Move(dbrec^,dbsort^,Db3_reclen);

  l:=2;
  r:=Db3_filesize;
  i:=r-1;

  swapped:=TRUE;
  typ    :=Db3_fieldtype(no);

  WHILE (l<=r) AND swapped DO
    BEGIN
      swapped:=False;

    {----Bubble Up}
      FOR j:=r DOWNTO l DO
        BEGIN
        {----Fetch record j-1 & save it}
          Db3_read(j-1);
          s2:=Db3_field2str(no);
          Move(dbrec^,dbsort^,Db3_reclen);

        {----Fetch record j}
          Db3_read(j);
          s1:=Db3_field2str(no);

        {----Bubble}
          IF Compare(s1,s2)
            THEN Swap(j-1,j);
        END;
      l:=i+1;

    {----Bubble Down}
      IF swapped
        THEN
          BEGIN
            FOR j:=l TO r DO
              BEGIN
              {----Fetch record j-1 & save it}
                Db3_read(j-1);
                s2:=Db3_field2str(no);
                Move(dbrec^,dbsort^,Db3_reclen);

              {----Fetch record j}
                Db3_read(j);
                s1:=Db3_field2str(no);

              {----Bubble}
                IF Compare(s1,s2)
                  THEN Swap(j-1,j);
              END;
            r:=i-1;
          END;
    END;

  Freemem(dbsort,Db3_reclen+1);

  Db3_seekbof;
END; {of Db3_sort}

{---------------------------------------------------------}

BEGIN
  db3_ernr :=0;
  db3_fatal:=False;
  dbsearch :=NIL;
  dbrec    :=NIL;
END.


{ DOCUMENTATION }

Db3_01.PAS is written by

                Ir. G.W. van der Vegt
                Hondbroek 57
                6121 XB Born (L)

and uploaded as public domain software because the author likes to
share it with other Turbo Pascal Users. Please keep the source the
way it is and write extentions as separate units.

This unit provides read/write access to Dbase III (Plus) *.DBF files. The
unit is uploaded as it is, the author is not responsible for any damgage
by programs using this module. The unit is, of course, tested.

Before using any of the Db3 routine a program shall call Db3_open to
initialize the file internal buffers & info. When finishing the program
should call Db3_close to close the file & cleanup the internal buffer.

All routines are documented so there's not much to say about them. Access
to the DBF file is only allowed through this unit, so the file record
isn't exported.

Records must be read by Db3_read or Db3_readnext, and written by Db3_append
or Db3_replace. All record functions use LONGINTs as parameter for addressing
records in the file.

When a record is read, one can read the field in the record by using the
record number as parameter of the Db3_field2 procedures. This record
number lies between 1 and maxfield. If one 's to be independend of the
location of the record the Db3_fieldno can be used to convert a field
name to the field number.

When writing records fill all field with Db3_2field routines and don't
forget to use Db3_undelete to initialize the deleted marker. It's of
course also possible to read a record, modify some field and replace it.

The Db3_pack routine packs the file in-place, so no temp file is created.

This unit can't create DBase III *.DBF files as it can't write the file
header & fieldefinitions. It's also impossble to change the structure of
a DBase III *.DBF database with it. This is done to keep the unit simple.
Creating & modifing databases is much easier in Dbase III Language.

This unit uses a special naming convention to be sure there's no
confict with procedures from other units. All exported names have
a three letter prefix Db3_. The 01 in the Unit name is a unique
version number.